home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Serious Software / Cherwell Scientific Demos / pro Fit / pro Fit 5.0 demo (fpu).sea / pro Fit 5.0 demo (fpu) / Functions & Programs / Pie and Bar chart / Pie and Bar chart program < prev    next >
Text File  |  1996-04-21  |  6KB  |  210 lines
  1. {
  2. This program generates pie or bar charts from a one dimensional data set. 
  3.  
  4. To run the program, click the button "Add" to compile it, then choose
  5. the program "PieOrBarChart" from the menu "Misc".
  6.  
  7. The input of the data for PieOrBarChart must reside in one column of
  8. a data window.
  9. }
  10.  
  11. program PieOrBarChart;
  12.  
  13. const thick=20;
  14.       hpos=200;
  15.       vpos=150;
  16.       hsize=100;
  17.       vsize=50;
  18.       step=0.1;
  19.       off=10;
  20.       maxNrColors = 12;
  21. var sum, nn, n, i, j, xcol, val, curAngle, what, windID: extended;
  22.     fontSize, dLab: extended;
  23.     colRED, colGREEN, colBLUE: array[1..maxNrColors] of extended;
  24.  
  25. procedure Initialize;
  26. begin
  27.   xcol := 1; { column 1 }
  28.   what := 1; { draw as pie chart }
  29.   dLab := 1; { draw with labels }
  30.   { The following is a color table. It could be easily extended if necessary. }
  31.   colRED[1]  := 65535; colGREEN[1]  := 0;     colBLUE[1]  := 65535;    { magenta }
  32.   colRED[2]  := 0;     colGREEN[2]  := 0;     colBLUE[2]  := 65535;    { blue }
  33.   colRED[3]  := 0;     colGREEN[3]  := 65535; colBLUE[3]  := 65535;    { cyan }
  34.   colRED[4]  := 0;     colGREEN[4]  := 32767; colBLUE[4]  := 8191;     { dark green }
  35.   colRED[5]  := 0;     colGREEN[5]  := 65535; colBLUE[5]  := 0;        { light green }
  36.   colRED[6]  := 65535; colGREEN[6]  := 65535; colBLUE[6]  := 0;        { yellow }
  37.   colRED[7]  := 65535; colGREEN[7]  := 32767; colBLUE[7]  := 0;        { orange }
  38.   colRED[8]  := 65535; colGREEN[8]  := 0;     colBLUE[8]  := 0;        { red }
  39.   colRED[9]  := 65535; colGREEN[9]  := 65535; colBLUE[9]  := 65535;    { white }
  40.   colRED[10] := 49150; colGREEN[10] := 49150; colBLUE[10] := 49150;    { light grey }
  41.   colRED[11] := 32767; colGREEN[11] := 32767; colBLUE[11] := 32767;    { grey }
  42.   colRED[12] := 16383; colGREEN[12] := 16383; colBLUE[12] := 16383;    { dark grey }
  43. end;
  44.  
  45. procedure DrawPiece(value, num);
  46. var pos, dif, vale;
  47. begin
  48.         dif := 2 * hsize / nn - 5;
  49.         if dif < 0 then
  50.           dif := 0;
  51.   pos := hpos - hsize + (num-1) * 2 * hsize / nn;
  52.   vale := value / (sum / nn) * vsize;
  53.   
  54.   GroupBegin;
  55.   OpenPoly(0, true);        { side }
  56.   MoveTo(pos + dif, vpos - vale);
  57.   LineTo(pos + off + dif,  vpos - vale - off);
  58.   LineTo(pos + off + dif,  vpos - off);
  59.   LineTo(pos + dif,  vpos);
  60.   LineTo(pos + dif,  vpos - vale);
  61.   ClosePoly;
  62.   if dif > 0 then
  63.   begin
  64.     OpenPoly(0, true);        { front }
  65.     MoveTo(pos, vpos);
  66.     LineTo(pos, vpos - vale);
  67.     LineTo(pos + dif,  vpos - vale);
  68.     LineTo(pos + dif,  vpos);
  69.     LineTo(pos,  vpos);
  70.     ClosePoly;
  71.     OpenPoly(0, true);        { top }
  72.     MoveTo(pos, vpos - vale);
  73.     LineTo(pos + off,  vpos - vale - off);
  74.     LineTo(pos + off + dif,  vpos - vale - off);
  75.     LineTo(pos + dif,  vpos - vale);
  76.     LineTo(pos,  vpos - vale);
  77.     ClosePoly;
  78.   end;
  79.   GroupEnd;
  80.   
  81.   SetFillPattern(1);
  82.   if dLab <> 0 then
  83.   begin
  84.     MoveTo(pos + dif / 2, vpos + 2 * fontSize);
  85.     DrawNumber(value, 2, 90, true);
  86.   end;
  87. end;
  88.  
  89. procedure DrawPie(value);
  90. var newAngle, oldAngle, meanAngle, angle;
  91. begin
  92.   newAngle := value/sum * 2 * π + curAngle;
  93.   if newAngle > 2*π then
  94.     newAngle := 2*π;
  95.   oldAngle := curAngle;
  96.   meanAngle := (oldAngle + newAngle) / 2;
  97.   GroupBegin;
  98.   
  99.   angle := oldAngle;
  100.   while ((angle >= π) and (angle < 2*π)) do
  101.           angle := angle + step;
  102.         if (angle > 2*π) then angle:=2*π;
  103.         if (angle < newAngle) then
  104.   begin
  105.     OpenPoly(0, true);
  106.     MoveTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle));
  107.     LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle) + thick);
  108.     while ((angle < π) and (angle < newAngle)) do
  109.     begin
  110.       angle := angle + step;
  111.       if (angle > π) then angle:=π;
  112.       if (angle > newAngle) then angle:=newAngle;
  113.       LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle) + thick);
  114.     end;
  115.     LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle));
  116.     ClosePoly;
  117.   end;
  118.   
  119.   angle := curAngle;
  120.   OpenPoly(0, true);
  121.   MoveTo(hpos, vpos);
  122.   LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle));
  123.   while (angle + step < newAngle) do
  124.   begin
  125.     angle := angle + step;
  126.     LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle));
  127.   end;
  128.   angle := newAngle;
  129.   LineTo(hpos + hsize*cos(angle), vpos + vsize*sin(angle));
  130.   LineTo(hpos, vpos);
  131.   ClosePoly;
  132.   GroupEnd;
  133.   
  134.   SetFillPattern(1);
  135.     if dLab <> 0 then
  136.   begin
  137.     if ((meanAngle > π) and (meanAngle < 2*π)) then
  138.          MoveTo(hpos + (hsize+20)*cos(meanAngle), vpos + (vsize+20)*sin(meanAngle))
  139.     else
  140.          MoveTo(hpos + (hsize+20)*cos(meanAngle), vpos + thick +(vsize+20)*sin(meanAngle));
  141.     DrawNumber(value, 2, 0, true);
  142.   end;
  143.   curAngle := newAngle;
  144. end;
  145.  
  146.  
  147. begin
  148.  Input('$CTake values from', xcol, '$PPie chart;Bar chart$Draw as', what, '$XWith labels', dLab);
  149.  sum := 0;
  150.  nn := 0;
  151.  for i:=1 to nrRows do
  152.    if dataOK(i, xcol) then
  153.    begin
  154.      val := data[i, xcol];
  155.      if (val > 0) then
  156.      begin
  157.                 sum := sum + val;
  158.                 nn := nn + 1;
  159.         end;
  160.          end;
  161.  if nn > 50 then
  162.  begin
  163.    Alert('Too many data selected (> 50).');
  164.    Halt;
  165.  end;
  166.  if nn > 20 then
  167.    DisableDrawingUpdates;
  168.  windID := FrontmostWindow(drawingType);
  169.  if windID = 0 then
  170.    NewWindow(drawingType)
  171.  else
  172.    BringWindowToFront(windID);
  173.  fontSize := Round(140 / nn);
  174.  if fontSize < 6 then
  175.    fontSize := 6;
  176.  if fontSize > 14 then
  177.    fontSize := 14;
  178.  SetTextStyle('',fontSize,plain);
  179.  
  180.  if sum > 0 then
  181.  begin
  182.    SetLineColor(0, 0, 0);
  183.    curAngle := 0;
  184.    j := 0;
  185.    n := 0;
  186.    GroupBegin;
  187.      for i:= 1 to nrRows do
  188.        if dataOK(i, xcol) then
  189.        begin
  190.          val := data[i, xcol];
  191.          if (val > 0) then
  192.          begin
  193.                     j := j + 1;
  194.                     n := n + 1;
  195.                  if j > maxNrColors then
  196.                          j:= 1;
  197.                     SetFillColor(colRED[j], colGREEN[j], colBLUE[j]);
  198.            SetFillPattern(2);
  199.                  if what = 1 then
  200.                    DrawPie(val)
  201.                  else
  202.                    DrawPiece(val, n);
  203.          end;
  204.        end;
  205.    GroupEnd;
  206.  end
  207.  else
  208.    Beep;
  209.  end;
  210. end;